Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / casemod.txt < prev next >

Wrap

Text File | 1995-11-22 | 7.6 KB | 346 lines | [TEXT/MSET]

\ This module handles the implementation of our case constructs \ CASE[ and SELECT[. \ Notice that we don't use any assembler at all, and only need one \ special handler word CaseJMP to compile an indexed dispatch for SELECT[. \ We compile sequences that the optimizer will pick up so that the resulting \ code is pretty well optimum anyway. The key to this is the use of the \ pseudo-value "Treg" which is actually the machine register D1. type{ keyed_case indexed_case } 240 constant KEYED_CHK 250 constant INDEXED_CHK : CASE[ \ ( -- Schain Fchain endChain diff end-stub? chk ) \ Implements CASE[ in main dic. case_type \ save over nested cases keyed_case -> case_type eval" -> treg" 0 \ initial success chain 0 \ initial fail chain 0 \ initial end chain 0 \ initial diff false \ no end of stub yet keyed_chk \ check value postpone [ ; immediate : ADD_ENTRY { ccmp mark-addr chk link -- link' } link IF link mark-addr wdispl! \ store new mark at prev addr if any THEN mark-addr \ mark addr is new link ccmp $ 100 and IF 1+ THEN ; \ Store "dontShorten" flag in low bit : RESOLVE { link \ link' nxt -- } BEGIN link -2 and -> link' link' WHILE link' wdisplace -> nxt link 1 and IF $ 100 ELSE 0 THEN link' 120 >resolve nxt -> link REPEAT ; : RESOLVEF { link \ link' nxt -- } BEGIN link -2 and -> link' link' WHILE link' wdisplace -> nxt link 1 and IF $ 100 ELSE 0 THEN link' 120 >resolve nxt -> link link IF postpone literal eval" ++> treg" THEN REPEAT ; \ FIX_STUB is called at the end of a stub. We do many strange and \ intricate things... : FIX_STUB { Schain Fchain endChain \ svMC -- endChain' } moveCode? -> svMC Fchain wdisplace IF compBR >mark endChain add_entry -> endChain false -> moveCode? Fchain resolveF ELSE compBR 0 w, Schain \ This is Schain which we've already resolved at the \ the start of the stub, but we need it here to find out IF \ if there were several "success" items - if so, we \ can't shorten the "fail" branch(es) false -> moveCode? THEN Fchain resolveF 2 --> DP >mark endChain add_entry -> endChain THEN svMC -> moveCode? endChain ; : NEW_STUB { Schain Fchain endChain diff end-stub? chk lo hi flg \ svMC -- Schain' Fchain' endChain' diff end-stub? chk } postpone ] \ Must be compiling for evaluates below keyed_chk chk ?pairs end-stub? \ NZ if ending a stub IF Schain Fchain endChain fix_stub -> endChain 0 -> Schain 0 -> Fchain THEN hi lo <> IF lo diff - postpone literal eval" --> treg treg 0>= if" Fchain add_entry -> Fchain hi lo - hi lo - postpone literal eval" --> treg treg 0<=" flg IF postpone if Fchain add_entry -> Fchain ELSE postpone nif dontShorten Schain add_entry -> Schain THEN ELSE hi diff - postpone literal eval" --> treg treg" flg IF postpone nif Fchain add_entry -> Fchain ELSE postpone if Schain add_entry -> Schain THEN THEN lo -> diff flg IF Schain resolve Schain IF here 2- -> Fchain THEN \ we clear Schain next time around, \ since at FIX_STUB we need to know \ whether anything was on it ELSE hi lo <> IF moveCode? -> svMC false -> moveCode? \ For several reasons! postpone literal eval" ++> treg" Fchain resolve 0 -> Fchain svMC -> moveCode? THEN THEN Schain Fchain endChain diff flg \ flg is end_stub? for next time keyed_chk ; : DEFAULT { Schain Fchain endChain diff end-stub? chk -- endChain chk } keyed_chk chk ?pairs end-stub? IF Schain Fchain endChain fix_stub -> endChain THEN postpone treg diff postpone literal postpone + endChain keyed_chk 1+ ; : ]CASE { endChain chk \ svMC -- } keyed_chk 1+ chk ?pairs moveCode? -> svMC false -> moveCode? endChain resolve svMC -> moveCode? -> case_type ; immediate \ Now for an indexed case, with similar style syntax: 0 value MAXINDEX 0 value MININDEX 0 value ADDRX \ just for testing : SELECT[ \ ( -- lots ) case_type maxindex minindex \ Save on stack for nested cases indexed_case -> case_type 0 -> maxindex big# -> minindex compBr >mark \ Forward branch to dispatch code dontShorten \ Penalty: a terrible death 1 \ Dummy, so ]SELECT knows when to stop 0 \ initial end chain false \ no end of stub yet indexed_chk \ check value postpone [ ; immediate : TBL_NEW_STUB { endChain end-stub? chk index flg -- index here endChain' end-stub? chk } postpone ] index 0< ?error 102 index maxindex max -> maxindex index minindex min -> minindex maxindex 500 > if msg# 85 then end-stub? IF compbr >mark endChain add_entry -> endChain THEN index here endChain flg \ flg is end_stub? for next time indexed_chk ; : TBL_DEFAULT { endChain end-stub? chk -- dflt-addr endChain chk } postpone ] end-stub? IF compbr >mark endChain add_entry -> endChain THEN here \ here's where the default code will start \ now we generate the code to recover the original index eval" treg 2/ -> treg" minindex postpone literal eval" ++> treg treg" endChain indexed_chk 1+ ; : ]SELECT ( ... index addr index addr ) { dflt-addr endChain chk \ tbl_start svDP -- } indexed_chk 1+ chk ?pairs compbr >mark endChain add_entry -> endChain \ wind up default stub \ Now we build the table: here -> tbl_start maxindex minindex - 1+ 2* allot dflt-addr tbl_start - ( now relative to tbl_addr ) here 2- \ last entry addr tbl_start DO ( fill table with dflt addr initially ) dup i w! 2 +LOOP drop BEGIN ( index addr ) dup 1 = NWHILE ( index addr ) tbl_start - swap minindex - 2* tbl_start + w! REPEAT drop \ Now we generate the dispatch code: ( >mark-from-initial-branch ) >resolve eval" -> treg treg +> treg" minindex 2* postpone literal eval" --> treg" \ Compiles nothing if minindex is zero maxindex minindex - 2* postpone literal eval" treg u< nif" false -> moveCode? dflt-addr -> DP >resolve \ branch is actually back, but that's OK \ so long as we inhibit code movement frNxtDP -> DP tbl_start lit-addr eval" treg + w@x -> tareg" tbl_start lit-addr eval" tareg +" caseJMP endChain resolve \ can't move code or initial branch true -> moveCode? \ would be wrong -> minindex -> maxindex -> case_type ; immediate \ These words are the same in both constructs, so we work out which action \ to apply by looking at case_type. : ]=> case_type keyed_case = IF dup true new_stub ELSE true tbl_new_stub THEN ; immediate : ], case_type keyed_case = IF dup false new_stub ELSE false tbl_new_stub THEN ; immediate : RANGE]=> true new_stub ; immediate : RANGE], false new_stub ; immediate : DEFAULT=> case_type keyed_case = IF default ELSE tbl_default THEN ; immediate endload +echo \ Something as complicated as that needs a bit of systematic testing... : qq db case[ 21 ]=> 210 [ 22 ]=> 220 [ 80 ], [ 82 ], [ 84 ], [ 86 ]=> 888 [ 30 40 range]=> 333 [ 90 ], [ 92 ], [ 170 ]=> -999 [ 90 ], [ 92 ], [ 100 150 range], [ 170 ]=> -999 [ 222 ]=> 2220 default=> 99 ]case ; : q db select[ 3 ]=> 23 [ 2 ]=> 22 \ [ 0 ]=> 20 [ 8 ]=> 28 default=> 999 ]select ; : ?CHK <> abort" check FAILED!!!" ; \ endload +echo 21 qq 210 ?chk 22 qq 220 ?chk 80 qq 888 ?chk 84 qq 888 ?chk 85 qq 99 ?chk 85 ?chk 35 qq 333 ?chk 92 qq -999 ?chk 120 qq -999 ?chk 170 qq -999 ?chk 222 qq 2220 ?chk 9999 qq 99 ?chk 9999 ?chk 3 q 23 ?chk 2 q 22 ?chk 8 q 28 ?chk 6 q 999 ?chk 6 ?chk -1 q 999 ?chk -1 ?chk 9 q 999 ?chk 9 ?chk \ torture tests WORKED!